perm filename PTMOVE.F4[MSS,LCS]1 blob sn#169961 filedate 1975-07-25 generic text, type T, neo UTF8
00100	C******  PTMOVE.F4
00200		SUBROUTINE PTMOVE
00300		IMPLICIT INTEGER(A-Q,S-Z)
00400		DIMENSION R(2,200),IR(2,200)
00450		COMMON/KNR/KR(500) /NNP/NP(500)
00500		REAL PWDS,POS,EXTEN,PRCNT
00600		COMMON/STF/RSTFAC(-3/4),RSTJ2
00700		COMMON/XRN/RN(4000)  /KJY/ KY,JY
00800		COMMON R2,JA,CENTR,J2,RJQ(18),RNO,JR,LX,RDIS
00900		COMMON/POSI/STFF(-3/4),JJ2,POS/PTR/PWDS(250),ITEM,LL,I,IX
01200	      EQUIVALENCE (R5,RJQ(3)),(R6,RJQ(4)),(R7,RJQ(5)),(R4,RJQ(2))
01300		1,(R3,RJQ(1)),(R8,RJQ(6)),(R9,RJQ(7))
01400		1,(IR,R)
01500		DATA RSP/.5/,RI/4.5/
01600	
01700		JJ2=-1
01800		J2=0
02000	C  99=BACKUP
02600		IF(LL.EQ.'J')GO TO 12
02700		RDIS=0
05575	CCC66	NST=1
05800		JJ=0 
05900		IF(R4.NE.R8.OR.R5.NE.R9)JJ=-1
05950		JY=0
05960	C  JY IS CHANGED IN GETPTS
06000		IF(JJ)CALL GETPTS(LX)
06220		IF(JY.EQ.0)RETURN
06300		CALL MOVIT
06400		RETURN
06660	12	IF(R4.EQ.0)R4=.001
06670	CCC	IF(R5.EQ.0)R5=200
06680		RCNT=0
06700		RRT=R5
06800		RZRO=R4
07200		RJSZ=RI
07300		CALL GETPTS(LX)
07350		IF(JY.EQ.0)RETURN
07400		ROV=RRT
07500		PRCNT=1.
07600		R7=R2
07700		R6=0
07900	19	IF(RCNT.GT.9)GO TO 101
08000		RJSZ=RJSZ-.06
08100		RP=PRCNT
08200		RCNT=RCNT+1
08500	
08600	CCC	DO 11 KN=-3,4
08650		KN=R2
08700		RSPC=0
08800	CCC	R8=KN
08900		N=0
09000	
09100		DO 2 K=1,KY-1
09150	C   -1 ABOVE BECAUSE GETPTS GOES TOO FAR
09200		L=NP(K)
09300		RL=RN(L)
09365		RA=RN(L+1)
09430		RB=RN(L+3)
09495	CCC	IF(RN(L+2).EQ.R8)GO TO 77
09560	C  THIS STAFF?
09625	CCC	IF(RA.NE.4)GO TO 2
09690	C  SKIPS HOMED NOTES (IN CHORDS)
09755	CC77	IF(RA.EQ.1)GO TO 10
09820	CC27	IF(RA.LE.4)GO TO 177
09885	77	IF(RA.LT.3)GO TO 10
09950		IF(RA.EQ.4)GO TO 444
10015		IF(RA.EQ.3)GO TO 333
10080	C  LOOKS AT NOTES,RESTS,CLEFS,BAR LINES,KSIGS,METERS.
10145		IF(RA.LT.17)GO TO 2
10210		GO TO 10
10275	333	IF(RL.LT.3)GO TO 10
10340	C  <3 MEANS NOTHING IN P5
10405		IF(RN(L+5).GT.3)GO TO 2
10470	C  NOT A REAL CLEF IF >3
10535		GO TO 10
10600	444	IF(RL.GT.2)GO TO 2
10665	C  SHOULD CHECK ON BAR LINES NO MATTER WHICH STAFF
10730	10	N=N+1
10800		R(1,N)=RB
10900		IR(2,N)=L
11000		IF(N.EQ.200)GO TO 28
11100	C  ONLY TREATS 200 ITEMS AT A TIME.
11200	2	CONTINUE
11300	
11400		IF(N.EQ.0)GO TO 11
11500	28	DO 23 K=1,N
11600	23	IF(RN(IR(2,K)+1).NE.4)GO TO 24
11700	C  SKIPS IF ONLY BAR LINES ON THIS STAFF
11800		GO TO 11
11900	24	RSTJ2=RSTFAC(KN)*PRCNT
12000	CC ALREADY SORTED IN 'PARTS'.	CALL SORT2(R,N)
12100	
12200	C  JUMP IF LAST IS A BAR LINE.
12300		K=0
12400		JLDGR=0
12500	     	JX=0
12600	22	K=K+1
12700	122	L=IR(2,K)
12800		RA=RN(L+1)
12900		RB=0
13000		RX=RN(L+5)
13100	C  RX=PARAM 5
13200		RX6=RN(L+6)
13300		RY=1
13400		RW=AMOD(RN(L+4),100.)
13500		IF(RA.GT.1)GO TO 4
13600		RZ=RN(L+7)
13700		IF(LDGR.NE.JLDGR)JLDGR=0
13800		LDGR=0
13900		JK=K
14000		DO 32 JJ=JK+1,N+1
14100		K=JJ
14200	32	IF(R(1,JJ)-R(1,JJ-1).GT.RSP)GO TO 35
14300	C  FOUND HOW MANY MEMBERS TO CHORD.
14400	35	RB=0
14500		K=K-1
14600		RQ=0
14700		RD=0
14800	125	IF(AMOD(RN(L+4),200.).GT.60.)RY=.6
14900		DO 37 JJ=JK,K-1
15000		IF(RD.NE.0)GO TO 38
15100	C FINDS ONLY HIGH OR! LOW LED. LINE.
15200		JR=IR(2,JJ)
15300		RW=AMOD(RN(JR+4),100.)
15400		IF(RW.GT.12)GO TO 277
15500		IF(RW.GE.2)GO TO 38
15600	277	LDGR=-1
15700		IF(RW.GT.11)LDGR=1
15800		IF(JLDGR.EQ.LDGR)GO TO 36
15900		JLDGR=LDGR
16000	C LDGR IS FOR LEDGER LINES.
16100		GO TO 38
16200	36	RD=1.5
16300		RQ=RD
16400	38	IF(RB.GT.2)GO TO 222
16500	C  JUMP IF LARGE SPACE AFTER NOTE IS ALREADY SET UP.
16600		RZZ=RN(JR+7)
16700		RE=RN(JR+5)
16800	CC	IF(RB.LT.2.AND.((AMOD(RZZ,10.).NE.0.AND.RE.LT.20).
16900	CC	1 OR.RZZ.GE.10))RB=1.5+EXTEN(RZZ)
17000		IF(RB.GE.2)GO TO 477
17100		IF(RZZ.GE.10)GO TO 377
17200		IF(RE.GE.20)GO TO 477
17300		IF(AMOD(RZZ,10.).EQ.0)GO TO 477
17400	377	RB=1.5+EXTEN(RZZ)
17500	C  SPACE FOR DOT OR TAIL(IF STEM UP)
17600	477	IF(ABS(RN(JR+6)).EQ.10)RB=RB+2
17700	C  FOR CHORD TONES ON RIGHT OF STEM UP.
17800	C  LOOKS THROUGH ALL NOTES OF A CHORD.
17900	222	IF(AMOD(RE,10.).EQ.0)GO TO 37 
18000	C  JUMP IF NO ACCIS.
18100	425	RD=2*RY+EXTEN(RE)
18200		IF(RQ.GT.RD)RD=RQ
18300		RQ=RD
18400	C  FUNCT. EXTEN=AMOD(X,1.)*10.
18500	37 	CONTINUE
18600		IF(RY.NE.1)RB=RB-.5*RJSZ
18700	C  MINI NOTES NEED LESS SPACE
18800	25	IF(JX.GT.0)R(2,JX)=R(2,JX)+RD*RSTJ2
18900		GO TO 17
19000	4	IF(RA.NE.3)GO TO 29
19100		RB=3
19200		IF(RX.GT.100)RB=1.5
19300	C  CHECK ON SIZE NEEDED FOR CLEFS
19400	29	IF(RA.NE.4)GO TO 26
19500		RB=-RJSZ/2
19600		RD=.9
19700		GO TO 25
19800	26	IF(RA.NE.18)GO TO 30
19900		IF(RX6.GT.9)GO TO 31
20000		IF(RX.GT.9)GO TO 31
20100	C  CHECKS FOR 2-DIGIT METERS
20200		RB=-1
20300		RD=1
20400		GO TO 25
20500	31	RB=2
20600		RD=3
20700		GO TO 25
20800	30	IF(RA.NE.17)GO TO 17
20900		RB=2*(ABS(RX)-1)-2
21000	C  SPACES FOR CORRECT NUM OF ACCIS.  RX=NUM OF ACCIS.
21100		RD=2
21200		GO TO 25
21300	17	RC=(RB+RJSZ)*RSTJ2
21400	C  RJSZ=DEFAULT SIZE
21500		JX=JX+1
21600		R(2,JX)=RC
21700		R(1,JX)=R(1,K)
21800	3	IF(K.LT.N)GO TO 22
21900		RA=R(1,1)
22000		RB=R(2,1)
22100	
22200		DO 13 KX=2,JX
22300		RE=R(1,KX)
22400	C  POS. BEFORE SHIFTING
22500		IF(ABS(RE-RA).GT..5)GO TO 14
22600		IF(R(2,KX).GT.RB)GO TO 16
22700	C  SKIPS DOUBLE STOPS AND VERY CLOSE ITEMS
22800		GO TO 13
22900	C  JUMP WHEN SPACE TO ADD IS SMALLER THAN WHAT'S ALREADY THERE
23000	14	RD=RA+RB-RE
23100		IF(RD.LE.0)GO TO 16
23200	C  THERE'S ENOUGH ROOM
23250		ROV=ROV+RD
24000	140	R4=RE+RSPC-.001
24100		R5=10000
24200		R8=RD
24300		R9=0
24600	C  GO EXPAND IT
24700		IF(R(2,KX).EQ.0)GO TO 15
24710		CALL MOVIT
24720		IF(R2.LE.4)GO TO 15
24725		R5=R4
24731		R4=RA+.001+RSPC
24753		R8=R4
24764		R9=R5+RD-.001
24770	C  FOR ITEMS ON OTHER LINES.
24775		CALL MOVIT
24780	15	RSPC=RSPC+RD
24790	C  RSPC SAVES TOTAL SPACE ADDED
24800	16	RB=R(2,KX)
24900	13	RA=RE
25000	11	CONTINUE
25100	110	IF(ROV.LE.RRT+.01)RETURN
25200		IF(RJSZ.GT.4)RJSZ=4
25300		PRCNT=(ROV-RZRO)/(RRT-RZRO)
25500		IF(PRCNT.NE.RP)GO TO 19
25600	C  GO BACK AND EXPAND SOME MORE
25700	101	R4=RZRO
25800		R5=ROV
25900		R8=RZRO
26000		R9=RRT-.001
26100	C  JUSTIFYING SPACE DIMINISHES EACH TIME AROUND.
26300		CALL MOVIT
27500	C  RVX SHOULD BE FARTHEST POINT TO RIGHT.
27850		END